home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / debug.scm < prev    next >
Encoding:
Text File  |  1995-03-20  |  7.0 KB  |  227 lines
  1. ;;;; "debug.scm" Utility functions for debugging in Scheme.
  2. ;;; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (define (debug:print . args)
  21.   (define result #f)
  22.   (for-each (lambda (x) (set! result x) (write x) (display #\ )) args)
  23.   (newline)
  24.   result)
  25.  
  26. (define *qp-width* (output-port-width (current-output-port)))
  27.  
  28. (define debug:qpn
  29.   (let ((newline newline) (apply apply))
  30.     (lambda objs (apply debug:qp objs) (newline))))
  31.  
  32. (define debug:qpr
  33.   (let ((- -) (apply apply) (length length) (list-ref list-ref))
  34.     (lambda objs (apply debug:qpn objs)
  35.         (list-ref objs (- (length objs) 1)))))
  36.  
  37. (define debug:qp
  38.   (let
  39.       ((+ +) (- -) (< <) (= =) (>= >=) (apply apply) (boolean? boolean?)
  40.        (car car) (cdr cdr) (char? char?) (display display) (eq? eq?)
  41.        (for-each for-each) (input-port? input-port?)
  42.        (not not) (null? null?) (number->string number->string)
  43.        (number? number?) (output-port? output-port?) (eof-object? eof-object?)
  44.        (procedure? procedure?) (string-length string-length)
  45.        (string? string?) (substring substring)
  46.        (symbol->string symbol->string) (symbol? symbol?)
  47.        (vector-length vector-length) (vector-ref vector-ref)
  48.        (vector? vector?) (write write) (quotient quotient))
  49.     (letrec
  50.     ((num-cdrs
  51.       (lambda (pairs max-cdrs)
  52.         (cond
  53.          ((null? pairs) 0)
  54.          ((< max-cdrs 1) 1)
  55.          ((pair? pairs) (+ 1 (num-cdrs (cdr pairs) (- max-cdrs 1))))
  56.          (else 1))))
  57.      
  58.      (l-elt-room
  59.       (lambda (room pairs)
  60.         (quotient room (num-cdrs pairs (quotient room 8)))))
  61.  
  62.      (qp-pairs
  63.       (lambda (cdrs room)
  64.         (cond
  65.          ((null? cdrs) 0)
  66.          ((not (pair? cdrs))
  67.           (display " . ")
  68.           (+ 3 (qp-obj cdrs (l-elt-room (- room 3) cdrs))))
  69.          ((< 11 room)
  70.           (display #\ )
  71.           ((lambda (used)
  72.          (+ (qp-pairs (cdr cdrs) (- room used)) used))
  73.            (+ 1 (qp-obj (car cdrs) (l-elt-room (- room 1) cdrs)))))
  74.          (else
  75.           (display " ...") 4))))
  76.  
  77.      (v-elt-room
  78.       (lambda (room vleft)
  79.         (quotient room (min vleft (quotient room 8)))))
  80.  
  81.      (qp-vect
  82.       (lambda (vect i room)
  83.         (cond
  84.          ((= (vector-length vect) i) 0)
  85.          ((< 11 room)
  86.           (display #\ )
  87.           ((lambda (used)
  88.          (+ (qp-vect vect (+ i 1) (- room used)) used))
  89.            (+ 1 (qp-obj (vector-ref vect i)
  90.                 (v-elt-room (- room 1)
  91.                     (- (vector-length vect) i))))))
  92.          (else
  93.           (display " ...") 4))))
  94.  
  95.      (qp-string
  96.       (lambda (str room)
  97.         (cond
  98.          ((>= (string-length str) room 3)
  99.           (display (substring str 0 (- room 3)))
  100.           (display "...")
  101.           room)
  102.          (else
  103.           (display str)
  104.           (string-length str)))))
  105.  
  106.      (qp-obj
  107.       (lambda (obj room)
  108.         (cond
  109.          ((null? obj) (write obj) 2)
  110.          ((boolean? obj) (write obj) 2)
  111.          ((char? obj) (write obj) 8)
  112.          ((number? obj) (qp-string (number->string obj) room))
  113.          ((string? obj)
  114.           (display #\")
  115.           ((lambda (ans) (display #\") ans)
  116.            (+ 2 (qp-string obj (- room 2)))))
  117.          ((symbol? obj) (qp-string (symbol->string obj) room))
  118.          ((input-port? obj) (display "#[input]") 8)
  119.          ((output-port? obj) (display "#[output]") 9)
  120.          ((procedure? obj) (display "#[proc]") 7)
  121.          ((eof-object? obj) (display "#[eof]") 6)
  122.          ((vector? obj)
  123.           (set! room (- room 3))
  124.           (display "#(")
  125.           ((lambda (used) (display #\)) (+ used 3))
  126.            (cond
  127.         ((= 0 (vector-length obj)) 0)
  128.         ((< room 8) (display "...") 3)
  129.         (else
  130.          ((lambda (used) (+ (qp-vect obj 1 (- room used)) used))
  131.           (qp-obj (vector-ref obj 0)
  132.               (v-elt-room room (vector-length obj))))))))
  133.          ((pair? obj) 
  134.           (set! room (- room 2))
  135.           (display #\()
  136.           ((lambda (used) (display #\)) (+ 2 used))
  137.            (if (< room 8) (begin (display "...") 3)
  138.            ((lambda (used)
  139.               (+ (qp-pairs (cdr obj) (- room used)) used))
  140.             (qp-obj (car obj) (l-elt-room room obj))))))
  141.          (else (display "#[unknown]") 10)))))
  142.  
  143.       (lambda objs
  144.     (qp-pairs (cdr objs)
  145.           (- *qp-width*
  146.              (qp-obj (car objs) (l-elt-room *qp-width* objs))))))))
  147.  
  148. ;;;; BREAKPOINTS
  149.  
  150. ;;; Typing (init-debug) at top level sets up a continuation for break.
  151. ;;; When (break arg1 ...) is then called it returns from the top level
  152. ;;; continuation and pushes the continuation from which it was called
  153. ;;; on debug:break-continuation-stack.  If (continue) is later
  154. ;;; called, it pops the topmost continuation off of
  155. ;;; debug:break-continuation-stack and returns #f to it.
  156.  
  157. (define debug:break-continuation-stack '())
  158.  
  159. (define debug:break
  160.   (let ((call-with-current-continuation call-with-current-continuation)
  161.     (apply apply) (qpn debug:qpn)
  162.     (cons cons) (length length))
  163.     (lambda args
  164.       (apply qpn "BREAK:" args)
  165.       (call-with-current-continuation
  166.        (lambda (x) 
  167.      (set! debug:break-continuation-stack
  168.            (cons x debug:break-continuation-stack))
  169.      (debug:top-continuation
  170.       (length debug:break-continuation-stack)))))))
  171.  
  172. (define debug:continue
  173.   (let ((null? null?) (car car) (cdr cdr))
  174.     (lambda ()
  175.       (cond ((null? debug:break-continuation-stack) #f)
  176.         (else
  177.          (let ((cont (car debug:break-continuation-stack)))
  178.            (set! debug:break-continuation-stack
  179.              (cdr debug:break-continuation-stack))
  180.            (cont #f)))))))
  181.  
  182. (define debug:top-continuation
  183.   (if (provided? 'abort)
  184.       (lambda (val) (display val) (newline) (abort))
  185.       (begin (display "; type (init-debug)") #f)))
  186.  
  187. (define (init-debug)
  188.   (call-with-current-continuation
  189.    (lambda (x) (set! debug:top-continuation x))))
  190.  
  191. (define (debug:trace-all file)
  192.   (call-with-input-file
  193.       file
  194.     (lambda (port)
  195.       (require 'trace)
  196.       (require 'line-i/o)
  197.       (let loop ((fc (peek-char port)))
  198.     (cond ((eof-object? fc))
  199.           ((char-whitespace? fc))
  200.           ((char=? #\; fc))
  201.           ((char=? #\( fc))
  202.           (else (read-line port) (loop (peek-char port)))))
  203.       (defmacro:eval
  204.         (cons 'trace
  205.               (do ((form (read port) (read port))
  206.                    (tlist '()
  207.               (if (and (pair? form)
  208.                    (eq? (car form) 'define)
  209.                    (or (pair? (cadr form))
  210.                        (and (pair? (caddr form))
  211.                         (list? (caddr form))
  212.                         (eq? 'lambda (caaddr form)))))
  213.                   (cons (if (pair? (cadr form))
  214.                     (caadr form)
  215.                     (cadr form))
  216.                     tlist)
  217.                   tlist)))
  218.                   ((eof-object? form) tlist)))))))
  219.  
  220. (define trace-all debug:trace-all)
  221. (define print debug:print)
  222. (define qp debug:qp)
  223. (define qpn debug:qpn)
  224. (define qpr debug:qpr)
  225. (define break debug:break)
  226. (define continue debug:continue)
  227.